home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 June: Reference Library / Dev.CD Jun 94.toast / Periodicals / develop / develop Issue 5 / develop 5 code / Lisp Mini-App / Program / utilities.lisp < prev   
Encoding:
Text File  |  1992-04-08  |  8.8 KB  |  216 lines  |  [TEXT/CCL2]
  1. #|
  2.    utilities.lisp
  3.  
  4.    Defines some utilities needed by the Mini-Application
  5.    sample program.
  6.  
  7.    For further info, see files "About Mini-App" and "Instructions".
  8.  
  9.  
  10.    Copyright 1990, 1991 by Ruben Kleiman for Apple Computer, Inc.
  11.    Acknowledgement: drag-inverted-region modified from a version by Dave Vronay.
  12.  
  13.    Change History.
  14.    03-12-92 slm  Updated file header comments.
  15.    01-19-92 slm  get-resource-handle: 
  16.                     added #_GetIcon for B&W systems after creating B&W ICONs.
  17.                     numberp -> integerp.
  18.                     ostype supersedes restype-from-string.
  19.                  restype-from-string: superseded so removed.
  20.    01-18-92 slm  macro get-wmgr-port has been updated:
  21.                     %stack-block -> rlet
  22.                     _GetWMgrPort -> require-trap #_GetWMgrPort
  23.    01-18-92 slm  function desktop-rect has been updated:
  24.                     get-record-field  -> pref
  25.                     #x9EE (=#$GrayRgn) -> #_GetGrayRgn
  26.    01-17-92 slm  ccl::class-precedence-list -> class-precedence-list
  27.                     now exported and documented.
  28.                  ccl::with-clip-rect -> with-clip-rect
  29.                     now exported but may not be documented.
  30.                  (ccl::mode-arg :patxor) -> (position :PatXOr *pen-modes*)
  31.                     Similarly for :patCopy.
  32.    01-17-92 slm  _openresfile      -> #_OpenResFile  (2x)
  33.                  _curresfile       -> #_CurResFile
  34.                  _useresfile       -> #_UseResFile   (2x)
  35.                  _GetCicon         -> #_GetCIcon
  36.                  _getnamedresource -> #_GetNamedResource
  37.                  _getresource      -> #_GetResource
  38.                  _GetPenState      -> #_GetPenState
  39.                  _PenMode          -> #_PenMode      (3x)
  40.                  _pt2rect          -> #_Pt2Rect      (2x)
  41.                  _FrameRect        -> #_FrameRect    (4x)
  42.                  _SetPenState      -> #_SetPenState
  43.                  _CopyRgn          -> #_CopyRgn      (4x)
  44.                  _InverRgn         -> #_InvertRgn    (3x)  ("t" added)
  45.                  _getmouse         -> #_GetMouse
  46.                  _offsetRgn        -> #_OffsetRgn
  47.                  _XORRgn           -> #_XOrRgn
  48.                  In addition, most keywords such as :errchk were removed.
  49.  
  50. |#
  51.  
  52. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  53. ;;;
  54. ;;; get-wmgr-port
  55. ;;;
  56. ;;;     Gets the window manager's port
  57. ;;;
  58. (defmacro get-wmgr-port ()
  59.   `(rlet ((port :pointer))
  60.      (require-trap #_GetWMgrPort port)
  61.      (%get-ptr port)))
  62.  
  63. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  64. ;;; open-resource-file
  65. ;;;
  66. ;;;    Given a filename, opens its resource fork.
  67. ;;;    Returns the file reference number.
  68. ;;;
  69. (defun open-resource-file (filename)
  70.   (let ((tempfile (with-pstrs ((tempfile (namestring (truename filename))))
  71.                     (#_OpenResFile tempfile))))
  72.     (if (/= tempfile -1)
  73.       tempfile)))
  74.  
  75. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  76. ;;; get-resource-handle
  77. ;;;
  78. ;;;  Given the resource type and either its name or id, returns its handle.
  79. ;;;  If a resource-file is provided, then that one will be used.
  80. ;;;
  81. (defun get-resource-handle (type name-or-id &optional resource-file 
  82.                                  &aux old-resource-file res)
  83.   (setq old-resource-file (#_CurResFile))
  84.   (unwind-protect
  85.     (progn
  86.       (unless (and (stringp type) (= (length type) 4))
  87.         (error "TYPE SHOULD BE A STRING OF LENGTH 4."))
  88.       (when (and resource-file
  89.                  (probe-file resource-file)
  90.                  (setq resource-file (namestring (truename resource-file))))
  91.         (with-pstrs ((fn resource-file))
  92.           (setq resource-file (#_OpenResFile fn)))
  93.         (#_UseResFile resource-file))
  94.       (case (read-from-string type)
  95.         (cicn (setq res (#_GetCIcon name-or-id)))  ;name-or-id must be ID
  96.         (ICON (setq res (#_GetIcon  name-or-id)))  ;name-or-id must be ID
  97.         (OTHERWISE
  98.          (cond ((stringp name-or-id)
  99.                 (with-pstrs ((name name-or-id))
  100.                   (setq res (#_GetNamedResource type name))))
  101.                ((integerp name-or-id)
  102.                 (setq res (#_GetResource type name-or-id)))
  103.                (t
  104.                 (error "A RESOURCE NAME OR ID SHOULD HAVE BEEN PROVIDED."))))))
  105.     (#_UseResFile old-resource-file)
  106.     res))
  107.  
  108. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  109. ;;; subclass-of
  110. ;;;
  111. ;;;   Is class A a subclass of B?
  112. ;;;
  113. (defun subclass-of (A B)
  114.   (and (symbolp A)
  115.        (symbolp B)
  116.        (memq (find-class A)
  117.              (class-precedence-list (find-class B)))
  118.        T))
  119.  
  120. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  121. ;;; select-rectangle [window]
  122. ;;;
  123. ;;;   This allows the user to drag a gray rectangle on a window
  124. ;;;   Returns the topleft and bottomright of the selected rectangle.
  125. ;;;
  126. (defmethod select-rectangle ((window window))
  127.   (let* ((anchor-point (view-mouse-position window))
  128.          (old-mouse anchor-point)
  129.          (new-mouse old-mouse)
  130.          (port (wptr window)))
  131.     (rlet ((r :rect)
  132.            (old-pen-state :penstate))
  133.       (with-port port
  134.         (#_GetPenState old-pen-state)
  135.         (#_PenMode (position :PatXOr *pen-modes*))
  136.         ; (rset port window.pnPat *gray-pattern*)
  137.         (#_Pt2Rect :long anchor-point :long new-mouse :ptr r)
  138.         (#_FrameRect r)
  139.         (loop
  140.           (unless (mouse-down-p) (return))     ;return when the mouse lets up
  141.           (unless (eq old-mouse new-mouse)
  142.             (#_FrameRect r)
  143.             (#_Pt2Rect :long anchor-point :long new-mouse :ptr r)
  144.             (#_FrameRect r)
  145.             (sleep 1/60)
  146.             (setq old-mouse new-mouse))
  147.           (setq new-mouse (view-mouse-position window)))
  148.         (#_FrameRect r)
  149.         (#_SetPenState old-pen-state)
  150.         (values (rref r rect.topleft)
  151.                 (rref r rect.bottomright))))))
  152.  
  153. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  154. ;;; desktop-rect
  155. ;;;
  156. ;;;   Returns the desktop rectangle.
  157. ;;;   Obviously not something whose value you should alter.
  158. ;;;
  159. (defun desktop-rect ()
  160.   (pref (#_GetGrayRgn) :region.rgnbbox))
  161.  
  162. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  163. ;;; drag-inverted-region
  164. ;;;
  165. ;;;   Will produce an inverted region which may be dragged with the mouse.
  166. ;;;   Returns the offset of the drag from the starting position.
  167. ;;;
  168. (defmethod drag-inverted-region ((window window) region &key (start 0))
  169.   (let* ((wOffset (view-position window))     ; Screen coordinates of window
  170.          (where (add-points start wOffset))   ; Screen coordinates of start position
  171.          (op where)
  172.          (mouse-rect (make-record :rect))     ; Rectangle for mouse position
  173.          (nregion (new-region))
  174.          (oregion (new-region))
  175.          (sregion (new-region))
  176.          (wideOpen (make-record :rect))       ; Clip to rectangle (will be desktop)
  177.          (old-point where)
  178.          (dragCenter 0)                       ; needs to be set to something ***
  179.          shift)
  180.     ;; Use desktop rectangle as the one to clip to:
  181.     (copy-record (desktop-rect) :rect wideOpen)
  182.     (unwind-protect
  183.       (progn
  184.         (offset-region region wOffset)
  185.         (with-port (get-wmgr-port)
  186.           (with-clip-rect wideOpen
  187.             (#_PenMode (position :PatXOr *pen-modes*))
  188.             (#_CopyRgn :ptr region  :ptr nregion)
  189.             (#_CopyRgn :ptr nregion :ptr oregion)
  190.             (#_InvertRgn :ptr oregion)
  191.             (do ((where where (progn (#_GetMouse :ptr mouse-rect)
  192.                                      (%get-long mouse-rect))))
  193.                 ((not (mouse-down-p))        ; Has mouse been released?
  194.                  (setq old-point where))     ; Yes: return where we are and quit DO
  195.               (cond ((eq old-point where))   ; Do nothing if mouse has not moved
  196.                     (T                       ; Mouse has moved!
  197.                      (#_CopyRgn :ptr oregion :ptr nregion)
  198.                      (setq shift (subtract-points where old-point)) ;; figure how far we moved
  199.                      (#_OffsetRgn :ptr region :long shift)  ;; offset the region
  200.                      (setq dragCenter (add-points shift dragCenter))
  201.                      (#_CopyRgn :ptr region :ptr oregion)
  202.                      (#_XOrRgn :ptr oregion :ptr nregion :ptr nregion)
  203.                      (#_InvertRgn :ptr nregion)
  204.                      (setq old-point where))))
  205.             (#_PenMode (position :patCopy *pen-modes*))
  206.             (#_InvertRgn :ptr oregion))))
  207.       (dispose-record mouse-rect :rect)
  208.       (dispose-record wideOpen :rect)
  209.       (dispose-region nregion)
  210.       (dispose-region oregion)
  211.       (dispose-region sregion))
  212.     (subtract-points old-point op)))
  213.  
  214. ;end of file utilities.lisp
  215. ;------------------------------------------------
  216.